home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / tpascal / vbxwz / samples / redgreen.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-12-13  |  5.4 KB  |  130 lines
  1. {---------------------------------------------}
  2. { This program create DLL file                }
  3. { (custom control) for Visual Basic           }
  4. {---------------------------------------------}
  5. library Red_Green;
  6. {$R REDGREEN.RES}
  7. uses WinTypes,WinProcs,BPVBApi;
  8. {---------------------------------------------}
  9. { Red_Green control data and structs          }
  10. {---------------------------------------------}
  11. type PRedGreen=^TRedGreen;
  12.      TRedGreen=record
  13.        Value:Bool;
  14.      end;
  15. {------------------------------}
  16. { Set new Item in Property     }
  17. {------------------------------}
  18. const Property_Value:TPROPINFO=(
  19.       npszName:NPnt(PChar('Value'));
  20.       fl:DT_Bool or PF_fGetData or PF_fSetData or PF_fSaveData or PF_fSetMsg;
  21.       offsetData:Byte(0);
  22.       infoData:0;
  23.       dataDefault:0;
  24.       npszEnumList:0;
  25.       enumMax:0);
  26. {------------------------------}
  27. { Set new all Property         }
  28. {------------------------------}
  29.       PropListRed_Green:array[0..10]of PPROPINFO =(
  30.       PPROPINFO_STD_CTLNAME,
  31.       PPROPINFO_STD_INDEX,
  32.       PPROPINFO_STD_LEFT,
  33.       PPROPINFO_STD_TOP,
  34.       PPROPINFO_STD_WIDTH,
  35.       PPROPINFO_STD_HEIGHT,
  36.       PPROPINFO_STD_VISIBLE,
  37.       PPROPINFO_STD_PARENT,
  38.       PPROPINFO_STD_TAG,
  39.       PPropInfo(@Property_Value),
  40.       0);
  41. {------------------------------------------------}
  42. { Event procedure parameter prototypes           }
  43. { Event list                                     }
  44. { Define the consecutive indicies for the events }
  45. {------------------------------------------------}
  46.       EventListRed_Green:array[0..1]of PEVENTINFO=(
  47.       PEVENTINFO_STD_MOUSEMOVE,
  48.       0);
  49. {------------------------------}
  50. { Constans and Variables       }
  51. {------------------------------}
  52. var   NewBMP:hBitmap;
  53.       Value:Bool;
  54. {------------------------------}
  55. { Show Bitmap (RED or GREEN)   }
  56. {------------------------------}
  57. procedure PaintBitmap(Control:hCtl;Wnd:hWnd;NewDC:hDC);
  58. const hbrOld:hBrush=0;
  59. var hBR:hBrush;
  60.     MemDC:hDC;
  61. begin
  62.   hBR:=GetBrushOrg(NewDC);                           {Get brush}
  63.   if Bool(hbr) then hbrOld:=SelectObject(NewDC,hBR); {Select Object to Paint and Save old Brush}
  64.   MemDC:=CreateCompatibleDC(NewDC);                  {Put Bitmap to Memory}
  65.   SelectObject(MemDC,NewBMP);                        {Select Object to Paint}
  66.   VBGetControlProperty(Control,9,@Value);
  67.   if Value then BitBlt(NewDC,0,0,29,16,MemDC,0,0,SrcCopy)  {Show Bitmap (GREEN) in Window}
  68.   else BitBlt(NewDC,0,0,29,16,MemDC,0,16,SrcCopy);   {Show Bitmap (RED) in Window}
  69.   SelectObject(Newdc,hbrOld);                        {Restore old brush}
  70.   DeleteDC(MemDC);                                   {Delete Bitmap from Memory}
  71. end;
  72. {-----------------------------------------------------}
  73. { Control Procedure                                   }
  74. { This routine is called for all VB and Windows Msgs. }
  75. {-----------------------------------------------------}
  76. function Red_GreenCtlProc(Control:HCtl;Wnd:HWnd;Msg,WParam:Word;LParam:LongInt):LongInt; export;
  77. var TP:TPaintStruct;
  78. begin
  79.   case Msg of
  80.     WM_PAINT:begin                         {If Paint Window}
  81.       BeginPaint(Wnd,TP);                  {Begin Paint Bitmap}
  82.       PaintBitmap(Control,Wnd,TP.hDC);     {Show the Bitmap}
  83.       EndPaint(Wnd,TP);                    {End Paint Bitmap}
  84.       Exit;                                {Exit from Message}
  85.     end;
  86.     VBM_SETPROPERTY:                       {If Check item from Property}
  87.     begin
  88.       if wParam=9 then InvalidateRect(Wnd,nil,False);
  89.     end;
  90.   end;
  91.   Red_GreenCtlProc:=VBDefControlProc(Control,Wnd,Msg,WParam,LParam);
  92. end;
  93. {--------------------------------------------}
  94. { Model struct                               }
  95. { Define the control model                   }
  96. { (using the event and property structures). }
  97. {--------------------------------------------}
  98. const   modelRed_Green:TMODEL=(
  99.     usVersion:VB_VERSION;               { VB version used by control}
  100.     fl:0;                                  { Bitfield structure}
  101.     ctlproc:TFarProc(@Red_GreenCtlProc);   { The control procudere.}
  102.     fsClassStyle:cs_VRedraw or cs_HRedraw; { Window class style}
  103.     flWndStyle:0;                        { Default window style}
  104.     cbCtlExtra:sizeof(TRedGreen);          { # bytes alloc'd for HCTL structure}
  105.     idBmpPalette:8000;               { BITMAP id for tool palette}
  106.     DefCtlName:NPnt(PChar('Red_Green'));   { Default control name prefix. Typecasts PChar to a NPnt.}
  107.     ClassName:NPnt(PChar('Red_Green'));    { Visual Basic class name}
  108.     ParentClassName:0;               { Parent window class if subclassed}
  109.     proplist:ofs(PropListRed_Green)    ;      { Property list}
  110.     eventlist:ofs(EventListRed_Green);     { Event list}
  111.     nDefProp:0;                       { Index of default property}
  112.     nDefEvent:0);                       { Index of default event}
  113. {----------------------------------------------}
  114. { Register custom control.                     }
  115. { This routine is called by VB when the custom }
  116. { control DLL is loaded for use.               }
  117. {----------------------------------------------}
  118. function VBINITCC(usVersion: Word; fRunTime: Boolean): Boolean; export;
  119. begin
  120.   NewBMP:=LoadBitmap(hInstance,'RED_GREEN');{Load Bitmap from RESOURCE}
  121.   VBINITCC:=VBRegisterModel(HInstance, modelRed_Green);
  122. end;
  123. {---------------------------------------------}
  124. { Export the Function and Procedures from DLL }
  125. {---------------------------------------------}
  126. exports
  127.   VBINITCC         index 2,
  128.   Red_GreenCtlProc index 3;
  129. begin
  130. end. {End of program}